home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / xlibpas2.zip / XCONVERT.PAS < prev    next >
Pascal/Delphi Source File  |  1994-06-11  |  9KB  |  400 lines
  1. Program XConvert;
  2.  
  3. Uses
  4.     XBm2, XMisc2, XGif2, Dos;
  5.  
  6. var
  7.     i : integer;
  8.     dir, tmp : DirStr;
  9.     name : NameStr;
  10.     DestExt,ext : ExtStr;
  11.     filenamein, filenameout, filenamewild : string;
  12.     S : SearchRec;
  13.     NextParam, TConv : string;
  14.     gifheight, gifwidth, error, StartParam, ConvFrom, Conversion : integer;
  15.     inbuff, outbuff : ^TByteArray;
  16.     inbuffoff : longint;
  17.     filein, fileout : file;
  18.  
  19. const
  20.     CBitmapWidth : integer = 80;
  21.  
  22. procedure GetPicLine( Var pixels; line, width : integer ); far;
  23. begin
  24.     blockwrite( fileout, pixels, width );
  25. end;
  26.  
  27. procedure DiscardPicLine( Var pixels; line, width : integer ); far;
  28. begin
  29. end;
  30.  
  31. procedure StoreLineBuff( Var pixels; line, width : integer ); far;
  32. begin
  33.     gifwidth := width;
  34.     gifheight := line+1;
  35.     if inbuffoff+width<65519 then
  36.         move( pixels, inbuff^[inbuffoff], width );
  37.     inbuffoff := inbuffoff + width;
  38. end;
  39.  
  40. function convert( filenamein, filenameout : string; ctype, intype : integer ) : boolean;
  41. var
  42.     size : longint;
  43.     actual : word;
  44.  
  45.     procedure Dealloc;
  46.     begin
  47.         freemem( inbuff, 65520 );
  48.         freemem( outbuff, 65520 );
  49.     end;
  50.  
  51. begin
  52.     inbuffoff := 0;
  53.     getmem( inbuff, 65520 );
  54.     getmem( outbuff, 65520 );
  55.     if Ctype=4 then
  56.     if (inType<>2) then
  57.         begin
  58.             writeln(' Invalid format ');
  59.             convert := false;
  60.             Dealloc;
  61.             exit;
  62.         end else
  63.         begin
  64.             GIFOutLineProc := GetPicLine;
  65.             {$I-}
  66.             assign(fileout, filenameout);
  67.             rewrite(fileout,1);
  68.             {$I+}
  69.             if IoResult>0 then
  70.             begin
  71.                 write(' Rewrite ');
  72.                 convert := false;
  73.                 Dealloc;
  74.                 exit;
  75.             end;
  76.             if LoadGif( filenamein ) > 0 then
  77.             begin
  78.                 write(' Invalid GIF file ');
  79.                 convert := false;
  80.                 Dealloc;
  81.                 close( fileout );
  82.                 exit;
  83.             end;
  84.             close( fileout );
  85.             convert := true;
  86.             Dealloc;
  87.             exit;
  88.         end;
  89.     if Ctype=3 then
  90.         if (inType<>2) then
  91.         begin
  92.             writeln(' No Pal Info ');
  93.             convert := false;
  94.             Dealloc;
  95.             exit;
  96.         end else
  97.         begin
  98.             GIFOutLineProc := DiscardPicLine;
  99.             {$I-}
  100.             assign(fileout, filenameout);
  101.             rewrite(fileout,1);
  102.             {$I+}
  103.             if IoResult>0 then
  104.             begin
  105.                 write(' Rewrite ');
  106.                 convert := false;
  107.                 Dealloc;
  108.                 exit;
  109.             end;
  110.             if LoadGif( filenamein ) > 0 then
  111.             begin
  112.                 write(' Invalid GIF file ');
  113.                 convert := false;
  114.                 Dealloc;
  115.                 close( fileout );
  116.                 exit;
  117.             end;
  118.             blockwrite( fileout, GIFPalette, sizeof(GIFPalette) );
  119.             close( fileout );
  120.             convert := true;
  121.             Dealloc;
  122.             exit;
  123.         end;
  124.     if intype = 2 then
  125.     begin
  126.         GIFOutLineProc := StoreLineBuff;
  127.         {$I-}
  128.         assign(fileout, filenameout);
  129.         rewrite(fileout,1);
  130.         {$I+}
  131.         if IoResult>0 then
  132.         begin
  133.             write(' Rewrite ');
  134.             convert := false;
  135.             Dealloc;
  136.             exit;
  137.         end;
  138.         if LoadGIF( filenamein ) > 0 then
  139.         begin
  140.             write(' Invalid GIF file ');
  141.             convert := false;
  142.             Dealloc;
  143.             close( fileout );
  144.             exit;
  145.         end;
  146.         if inbuffoff > 65516 then
  147.         begin
  148.             write(' >64K ');
  149.             convert := false;
  150.             Dealloc;
  151.             close( fileout );
  152.             exit;
  153.         end;
  154.         if gifwidth mod 4 <>0 then
  155.         begin
  156.             write(' Width is not a multiple of 4 ');
  157.             convert := false;
  158.             Dealloc;
  159.             close( fileout );
  160.             exit;
  161.         end;
  162.         if (gifwidth>255) or (gifheight>255) then
  163.         begin
  164.             write(' Image too big ');
  165.             convert := false;
  166.             Dealloc;
  167.             close( fileout );
  168.             exit;
  169.         end;
  170.         outbuff^[0] := gifwidth;
  171.         error := 1;
  172.         outbuff^[error] := gifheight;
  173.         move( inbuff^, outbuff^[error+1], inbuffoff );
  174.         case CType of
  175.             0 : ;
  176.             1 : xbmtopbm(outbuff^,inbuff^);
  177.             2 :
  178.                 begin
  179.                     if inbuffoff > 19000 then
  180.                     begin
  181.                         write(' Image too big ');
  182.                         convert := false;
  183.                         Dealloc;
  184.                         close( fileout );
  185.                         exit;
  186.                     end else
  187.                     begin
  188.                         size := xsizeofcbitmap(CBitmapWidth,outbuff^);
  189.                         xcompilebitmap(CBitmapWidth, inbuff^, outbuff^);
  190.                     end;
  191.                 end;
  192.             else
  193.                 begin
  194.                     writeln(' Can''t handle ');
  195.                     convert := false;
  196.                     close( filein );
  197.                     close( fileout );
  198.                     Dealloc;
  199.                     exit;
  200.                 end;
  201.         end;
  202.  
  203.  
  204.         convert := true;
  205.         Dealloc;
  206.         exit
  207.     end;
  208.     if ( Ctype>=0 ) and ( Ctype<=2 ) and ( intype>=0 ) and (intype<=1) then
  209.     begin
  210.         if Ctype = InType then
  211.         begin
  212.             write(' Nothing to do ');
  213.             Dealloc;
  214.             convert := false;
  215.             exit;
  216.         end;
  217.         {$I-}
  218.         assign(filein, filenamein);
  219.         reset(filein,1);
  220.         {$I+}
  221.         if IoResult>0 then
  222.         begin
  223.             write(' Reset ');
  224.             convert := false;
  225.             Dealloc;
  226.             exit;
  227.         end;
  228.         {$I-}
  229.         assign(fileout, filenameout);
  230.         rewrite(fileout,1);
  231.         {$I+}
  232.         if IoResult>0 then
  233.         begin
  234.             write(' Rewrite ');
  235.             convert := false;
  236.             Dealloc;
  237.             close( filein );
  238.             exit;
  239.         end;
  240.         size := filesize(filein);
  241.         if size>65528 then
  242.         begin
  243.             write(' >64K ');
  244.             convert := false;
  245.             Dealloc;
  246.             close( filein );
  247.             close( fileout );
  248.             exit;
  249.         end;
  250.         blockread( filein, inbuff^, size, Actual );
  251.         if actual<>size then
  252.         begin
  253.             write(' Read ');
  254.             convert := false;
  255.             close( filein );
  256.             close( fileout );
  257.             Dealloc;
  258.             exit;
  259.         end;
  260.         case ctype of
  261.             0 : if intype = 1 then xpbmtobm(inbuff^,outbuff^);
  262.             1 : if intype = 0 then xbmtopbm(inbuff^,outbuff^);
  263.             2 :
  264.                 begin
  265.                     if intype = 1 then
  266.                     begin
  267.                         size := xsizeofcpbm(CBitmapWidth,inbuff^);
  268.                         xcompilepbm(CBitmapWidth,inbuff^,outbuff^);
  269.                     end else
  270.                     begin
  271.                         size := xsizeofcbitmap(CBitmapWidth,inbuff^);
  272.                         xcompilebitmap(CBitmapWidth, inbuff^, outbuff^);
  273.                     end;
  274.                 end;
  275.             else
  276.                 begin
  277.                     writeln(' Can''t handle ');
  278.                     convert := false;
  279.                     close( filein );
  280.                     close( fileout );
  281.                     Dealloc;
  282.                     exit;
  283.                 end;
  284.         end;
  285.         blockwrite( fileout, outbuff^, size, Actual );
  286.         if actual<>size then
  287.         begin
  288.             write(' Write ');
  289.             convert := false;
  290.             close( filein );
  291.             close( fileout );
  292.             Dealloc;
  293.             exit;
  294.         end;
  295.         close( filein );
  296.         close( fileout );
  297.     end;
  298.     convert := true;
  299.     Dealloc;
  300. end;
  301.  
  302. procedure syntax;
  303. begin
  304.     writeln;
  305.     writeln('XConvert is a conversion utility which will convert a number of files');
  306.     writeln('to a format understandable by XLib routines.');
  307.     writeln('XConvert can read the following formats : ');
  308.     writeln('  LBM - XLib Linear bitmap');
  309.     writeln('  PBM - XLib Planar bitmap');
  310.     writeln('  GIF - Compuserve GIF');
  311.     writeln;
  312.     writeln('XConvert can write the following formats : ');
  313.     writeln('  LBM - XLib Linear bitmap');
  314.     writeln('  PBM - XLib Planar bitmap');
  315.     writeln('  CBM - XLib Compiled bitmap');
  316.     writeln('  PAL - XLib raw palette');
  317.     writeln('  SCR - XLib raw screen format');
  318.     writeln;
  319.     writeln('The -W parameter is used to specify the logical screen width for CBM''s');
  320.     writeln('The default value is 80 which is valid for a 320 pixel screen');
  321.     writeln;
  322.     writeln('  Usage :');
  323.     writeln('    XConvert -<LBM|PBM|CBM|PAL> [-W xxx] <filespec> [ <filespec> ..]');
  324.     halt(0);
  325. end;
  326.  
  327. begin
  328.     writeln('XConvert v1.0 - XLib Conversion utility - FREEWARE');
  329. {$IFDEF DPMI}
  330.     write('DPMI Version - ');
  331. {$ENDIF}
  332.     writeln('(C) 1994 - Tristan Tarrant');
  333.     if paramcount < 2 then syntax;
  334.     TConv := ParamStr(1);
  335.     XStrUpCase( TConv );
  336.     if TConv='-LBM' then
  337.         Conversion := 0
  338.     else
  339.     if TConv='-PBM' then
  340.         Conversion := 1
  341.     else
  342.     if TConv='-CBM' then
  343.         Conversion := 2
  344.     else
  345.     if TConv='-PAL' then
  346.         Conversion := 3
  347.     else
  348.     if TConv='-SCR' then
  349.         Conversion := 4
  350.     else syntax;
  351.     StartParam := 2;
  352.     NextParam := Paramstr(2);
  353.     XStrUpCase( NextParam );
  354.     if NextParam = '-W' then
  355.     begin
  356.         if ParamCount<4 then syntax;
  357.         StartParam := 4;
  358.         val(ParamStr(3), CBitmapWidth, error );
  359.         if error >0 then syntax;
  360.     end;
  361.     DestExt := '.'+copy(TConv,2,3);
  362.     for i := StartParam to Paramcount do
  363.     begin
  364.         filenamewild := ParamStr(i);
  365.         XStrUpCase( filenamewild );
  366.         fsplit(filenamewild,dir,name,ext);
  367.         if ext = '' then ext := '.LBM';
  368.         filenamewild := dir+name+ext;
  369.         findfirst(filenamewild,Archive,S);
  370.         while DosError = 0 do
  371.         begin
  372.             fsplit(S.name,tmp,name,ext);
  373.             if (ext<>'.LBM') and
  374.                  (ext<>'.PBM') and
  375.                  (ext<>'.GIF') then
  376.                         writeln('Skipping  : ',S.name, ' -> unknown type.')
  377.             else
  378.             begin
  379.                 if ext='.LBM' then
  380.                     ConvFrom := 0
  381.                 else
  382.                 if ext='.PBM' then
  383.                     ConvF